VERSION 5.00
Object = "{0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}#1.0#0"; "msscript.ocx"
Begin VB.Form frmScript 
   BorderStyle     =   0  'None
   Caption         =   "Form1"
   ClientHeight    =   570
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   570
   LinkTopic       =   "Form1"
   ScaleHeight     =   570
   ScaleWidth      =   570
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Visible         =   0   'False
   Begin MSScriptControlCtl.ScriptControl objSC_Syntax 
      Left            =   0
      Top             =   0
      _ExtentX        =   1005
      _ExtentY        =   1005
   End
End
Attribute VB_Name = "frmScript"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'-----------------------------------------------------------------
'             PT DC Hub @ Direct Connect P2P Network
'-----------------------------------------------------------------
'       Developer: Carlos.DF (fLaSh) - Portugal
'          E-mail: carlosferreiracarlos@hotmail.com
' Project started: 10 - September - 2006
'         License: GNU General Public License.
'-----------------------------------------------------------------
'       Thanks to developers and contributores of SDCH/DDCH
'         The Left Hand, ButterflySoul, HaArD and Selyb
'  TheNOP, RollTheDice, JDommi, GhOstFaCE, ArchaicLight and TUFF
'-----------------------------------------------------------------
Option Explicit
 
'API calls
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

'Constants
Private Const PPC_JSCRIPT       As Integer = 1
Private Const PPC_VBSCRIPT      As Integer = 2
'Private Const PPC_PERLSCRIPT    As Integer = 3

Private Const PPC_LIBRARY       As Integer = 4 Or PPC_VBSCRIPT Or PPC_JSCRIPT 'Or PPC_PERL
Private Const PPC_INCLUDE       As Integer = 8 Or PPC_VBSCRIPT Or PPC_JSCRIPT 'Or PPC_PERL
Private Const PPC_ENDIF         As Integer = 16 Or PPC_VBSCRIPT
Private Const PPC_ELSE          As Integer = 32 Or PPC_VBSCRIPT
Private Const PPC_IF            As Integer = 64 Or PPC_VBSCRIPT
Private Const PPC_ELSEIF        As Integer = 128 Or PPC_VBSCRIPT
Private Const PPC_CONST         As Integer = 256 Or PPC_VBSCRIPT

Private Const CHR_SHARP         As Integer = 35
Private Const CHR_AT            As Integer = 64

'Types
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * 260
    cAlternate As String * 14
End Type

Private Const n_sDefScript = _
    "Option Explicit" & vbTwoLine & _
    "Sub Main()" & vbTwoLine & _
    vbTab & "MsgBox ""Hello World!"", , ""VBScript""" & vbTwoLine & _
    "End Sub" & vbTwoLine & _
    "Sub Error(Line)" & vbNewLine & _
    vbTab & "MsgBox Err.Description" & vbNewLine & _
    "End Sub" & vbNewLine
    
Private m_CheckSyntaxErr   As Boolean
Private m_AddLogSyntaxErr  As Boolean

'Private variables
Private WithEvents m_objUpdate      As clsHTTPDownload
Attribute m_objUpdate.VB_VarHelpID = -1
 
Private Sub IniScriptContol(ByVal intIndex As Integer, ByRef objSC As ScriptControl)
1:    On Error GoTo Err

3:      If objSC.Tag = "Lua" Then
4:          Exit Sub
5:      End If
      
      'Forms
8:    objSC.AddObject "Core", frmHub
9:    objSC.AddObject "frmHub", frmHub
10:    objSC.AddObject "frmScript", frmScript
        
      'Default VB objects
13:    objSC.AddObject "App", App
14:    objSC.AddObject "Forms", Forms

      'Default DC objects
17:    objSC.AddObject "tmrScriptTimer", frmHub.tmrScriptTimer(intIndex)
18:    objSC.AddObject "colUsers", g_colUsers

      'Extended PTDCH objects
21:    objSC.AddObject "wskScript", g_colSWinsocks(CStr(intIndex)).wskScript
22:    objSC.AddObject "colStatic", g_colSVariables(CStr(intIndex))
23:    objSC.AddObject "ScriptCtrl", frmHub.ScriptControl(intIndex)
24:    objSC.AddObject "Settings", g_objSettings
25:    objSC.AddObject "Functions", g_objFunctions, True
26:    objSC.AddObject "colRegistered", g_objRegistered
27:    objSC.AddObject "colIPBans", g_colIPBans
28:    objSC.AddObject "FileAccess", g_objFileAccess
29:    objSC.AddObject "colCommands", g_colCommands
30:    objSC.AddObject "RegExps", g_objRegExps
31:    objSC.AddObject "colLanguages", g_colLanguages
#If Status Then
33:    objSC.AddObject "Status", g_objStatus
#End If
35:    objSC.AddObject "Sheduler", g_objScheduler
36:    objSC.AddObject "ChatRoom", g_objChatRoom
37:    objSC.AddObject "ActiveX", g_objActiveX
38:    objSC.AddObject "TimersAPI", frmHub.oTimersAPI
39:    objSC.AddObject "Debug", g_objDebugSC
40:    objSC.AddObject "MyIPTools", g_objMyIPTools

42:    Exit Sub
43:
Err:
44:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.IniScriptContol(" & objSC.Index & ")"
End Sub

Public Function CheckSintaxError(ByVal strScCode As String, ByVal objSC As ScriptControl, Optional bOnErrAddLog As Boolean = True, Optional bRunEvents As Boolean = True) As Boolean
1:    Dim intChar     As Integer
2:    Dim strCode     As String
3:    Dim strPath     As String
4:    On Error GoTo Err

  #If LUA Then
6:    If objSC.Tag = "Lua" Then
8:          Set g_objLua = g_colLua.Item(CStr(objSC.Index))
9:          If LenB(g_objLua.CheckSyntax(strScCode, bOnErrAddLog, bRunEvents)) = 0 Then
10:              CheckSintaxError = False
11:              frmHub.AddScriptLog objSC.Name, "No syntax error"
12:         Else
13:              CheckSintaxError = True
14:         End If
15:         Exit Function
16:    End If
   #End If
       'Set variable to false..
19:     m_CheckSyntaxErr = False
20:     m_AddLogSyntaxErr = bOnErrAddLog
       
       'Reset script code/objects then readd objects
23:    objSC_Syntax.Reset

      'Get copy language name
26:    objSC_Syntax.Language = objSC.Language
       
       'Ini all objects..
29:    IniScriptContol objSC.Index, objSC_Syntax
       
       'Get script file name
32:    objSC_Syntax.Tag = frmHub.lvwScripts.ListItems(objSC.Index & "s").Text

       'Get first char to identify language
35:    intChar = AscW(objSC_Syntax.Language)
    
37:    If intChar = 80 Then
38:        objSC_Syntax.AddCode strScCode
39:    Else
          'Prepare code buffer
41:        strCode = GenTempFile()
42:        g_objFileAccess.WriteFile strCode, strScCode
           'Do preparsing actions if JScript/VBScript
44:        strPath = SSPrereset(objSC_Syntax, strCode, vbNullString, intChar = 86)
           'Read code to control
46:        On Error Resume Next
47:        objSC_Syntax.AddCode g_objFileAccess.ReadFile(strPath)
48:        g_objFileAccess.DeleteFile strPath
49:        g_objFileAccess.DeleteFile strCode
50:    End If

       'If there was an error, then tell the user, and cancel reset
53:    If Not m_CheckSyntaxErr Then
          'Run Main
55:       If bRunEvents Then objSC_Syntax.Run "Main"
56:       If G_GUI_IN_UNLOAD Then
               'NOTE: it is possible if is used this code in this script:
               'For exemple:
               '     Sub Main()
               '         frmHub.APP_TERMINATE
               '     End Sub
               'This function set nothing all PTDCH objects.. however this process still continues!!
63:            End ' Hard end
64:       End If
          'Run UnloadMain
66:       If bRunEvents Then
67:          objSC_Syntax.Run "UnloadMain"
68:       End If
69:       If Not m_CheckSyntaxErr Then
70:          frmHub.AddScriptLog objSC_Syntax.Tag, "No syntax error script"
71:       End If
72:    End If
   
       'Remove code/objects
75:    objSC_Syntax.Reset

       'Return check.. true or false
78:    CheckSintaxError = m_CheckSyntaxErr
       
80:    Exit Function
    
82:
Err:
83:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.CheckSintaxError()"
84:    objSC_Syntax.Reset
85:    m_CheckSyntaxErr = True
End Function
Private Sub objSC_Syntax_Error()
1:    On Error Resume Next
      'Report error
2:    MsgBeep beepSystemDefault 'alert sound
3:    frmHub.AddScriptLog objSC_Syntax.Tag, "Syntax Error: " & objSC_Syntax.Error.Description & " on line " & objSC_Syntax.Error.Line
4:    m_CheckSyntaxErr = True
5:    'If m_AddLogSyntaxErr Then _
      AddLog "[" & Now & "] Syntax Error Script: " & objSC_Syntax.Tag & vbNewLine & _
             "Description: " & objSC_Syntax.Error.Description & vbNewLine & _
             "Text: " & objSC_Syntax.Error.Text & vbNewLine & _
             "Line: " & objSC_Syntax.Error.Line & vbNewLine & _
             "Column: " & objSC_Syntax.Error.Column & vbNewLine & _
             "Number: " & objSC_Syntax.Error.Number & vbNewLine & _
             "Source: " & objSC_Syntax.Error.Source
End Sub
Private Function SetSReset(ByVal intIndex As Integer, ByVal objSC As ScriptControl, Optional ByVal blnFirst As Boolean) As Boolean
1:    Dim intChar     As Integer
2:    Dim strCode     As String
3:    Dim strPath     As String
4:    Dim strScript   As String
5:    On Error GoTo Err

      'Get script code..
8:    strScript = frmHub.tbsScripts.Tabs(intIndex).Tag

  #If LUA Then
10:   If objSC.Tag = "Lua" Then
11:        Set g_objLua = g_colLua.Item(CStr(intIndex))
12:        Dim sResult As String
        
14:        If Not blnFirst Then
15:             g_objLua.UnloadMain
16:        End If
          
18:        sResult = g_objLua.CheckSyntax(strScript, False, False)
        
20:        If sResult = "" Then
21:              sResult = g_objLua.AddCode(strScript, True)
22:              If sResult = "" Then
                    'Make sure listitem is checked
24:                 With frmHub.lvwScripts
25:                     .ListItems(intIndex & "s").Checked = True
26:                     .ListItems(intIndex & "s").SubItems(1) = "Active"
27:                     .ListItems(intIndex & "s").SubItems(3) = Now
28:                 End With
29:                 If G_GUI_IN_UNLOAD Then
                        'NOTE: it is possible if is used this code in this script:
                        'For exemple:
                        '     function Main()
                        '         Core:APP_TERMINATE
                        '     end
                        'This function set nothing all PTDCH objects.. however this process still continues!!
36:                    End ' Hard end
37:                 End If
38:                 frmHub.AddScriptLog g_objLua.Name, "No syntax error"
39:                 SetSReset = True
40:              Else
41:                 GoTo SET_FALSE_LUA
42:              End If
43:        Else
SET_FALSE_LUA:
45:             g_objLua.Reset
               'Make sure listitem is checked
47:             With frmHub.lvwScripts
48:                 .ListItems(intIndex & "s").Checked = False
49:                 .ListItems(intIndex & "s").SubItems(1) = "Inactive"
50:                 .ListItems(intIndex & "s").SubItems(3) = Now
51:             End With
52:             SetSReset = False
53:             frmHub.AddScriptLog objSC.Tag, "Syntax Error: " & sResult
54:        End If
        
56:    Else
  #End If
       
58:        If Not blnFirst Then
            'Raise UnloadMain() event
60:            On Error Resume Next
61:            objSC.Run "UnloadMain"
62:            On Error GoTo Err
63:        End If
    
           'Reset script code/objects then readd objects
66:        objSC.Reset
        
           'Ini all objects..
69:        IniScriptContol objSC.Index, objSC
         
           'Get first char to identify language
72:        intChar = AscW(objSC.Language)
        
74:        If Not intChar = 80 Then
            'Prepare code buffer
76:            strCode = GenTempFile()
77:            g_objFileAccess.WriteFile strCode, strScript
            'Do preparsing actions if JScript/VBScript
79:            strPath = SSPrereset(objSC, strCode, vbNullString, intChar = 86)
            'Read code to control
81:            On Error Resume Next
82:            strScript = g_objFileAccess.ReadFile(strPath)
83:            g_objFileAccess.DeleteFile strPath
84:            g_objFileAccess.DeleteFile strCode
85:            On Error GoTo Err
86:        End If
        
           'Check syntax to detect possible errors..
89:        If Not CheckSintaxError(strScript, objSC, True, False) Then

91:            On Error Resume Next
92:            objSC.AddCode strScript
93:            On Error GoTo Err

               'Make sure listitem is checked
96:            With frmHub.lvwScripts
97:                .ListItems(intIndex & "s").Checked = True
98:                .ListItems(intIndex & "s").SubItems(1) = "Active"
99:                .ListItems(intIndex & "s").SubItems(3) = Now
100:            End With
            
               'Run Main Event
103:            On Error Resume Next
104:            objSC.Run "Main"
105:            If G_GUI_IN_UNLOAD Then
                   'NOTE: it is possible if is used this code in this script:
                   'For exemple:
                   '     Sub Main()
                   '         frmHub.APP_TERMINATE
                   '     End Sub
                   'This function set nothing all PTDCH objects.. however this process still continues!!
112:                End ' Hard end
113:            End If

115:            If objSC.Error.Number Then
116:                On Error Resume Next
117:                objSC.Run "UnloadMain"
118:                GoTo SET_FALSE_VBS_OR_JS
119:            Else
                    'Set events
121:                frmHub.SFindEvents intIndex
122:                SetSReset = True
123:            End If
            
125:        Else
SET_FALSE_VBS_OR_JS:
               'Remove code/objects again
128:            objSC.Reset
129:            frmHub.SClearEvents intIndex
130:            On Error GoTo Err
               'Make sure listitem is unchecked
132:            With frmHub.lvwScripts
133:                .ListItems(intIndex & "s").Checked = False
134:                .ListItems(intIndex & "s").SubItems(1) = "Inactive"
135:                .ListItems(intIndex & "s").SubItems(3) = Now
136:            End With
               'return False
138:            SetSReset = False
139:        End If

    #If LUA Then
140:    End If
    #End If
   
142:    Exit Function
    
144:
Err:
145:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.SetSReset(" & intIndex & ")"
146:    SetSReset = False

147:    On Error Resume Next
    #If LUA Then
148:    If objSC.Tag = "Lua" Then
149:        GoTo SET_FALSE_LUA
150:    Else
151:        GoTo SET_FALSE_VBS_OR_JS
152:    End If
    #Else
153:    GoTo SET_FALSE_VBS_OR_JS
    #End If
End Function
Public Sub SLoadDir()
1:     Static blnLoaded    As Boolean

3:     Dim objSC           As ScriptControl
4:     Dim frmWS           As frmSocks
5:     Dim objSV           As clsDictionary
6:     Dim WFD             As WIN32_FIND_DATA
7:     Dim frmLoop         As Form

9:     Dim lngOne          As Long
10:    Dim lngTwo          As Long
11:    Dim intIndex        As Integer
12:    Dim i               As Integer
13:    Dim strTemp         As String
14:    Dim strLanguage     As String

16:    On Error GoTo Err

       'Check to see if it's been loaded before
       'If True, then unload forms/listitems
20:    If blnLoaded Then

           'Lock update for picSciMain. Prevents ghostly text from appearing. Always a good idea to use nonetheless ;-)
23:        LockWindowUpdate frmHub.hwnd

           'Delete controls
26:        lngTwo = frmHub.ScriptControl.UBound
27:        If lngTwo Then
28:            For lngOne = 1 To lngTwo
29:                Unload frmHub.ScriptControl(lngOne)
30:                Unload frmHub.tmrScriptTimer(lngOne)
31:                g_objSciLexer(lngOne).Detach frmHub.picSciMain(lngOne)
32:                Set g_objSciLexer(lngOne) = Nothing
33:                Unload frmHub.picSciMain(lngOne)
34:            Next
35:        End If

           ' Erase array
38:        Erase g_objSciLexer()

           'Clear forms
41:        For Each frmLoop In Forms
                Select Case frmLoop.Name
                   Case "frmProperties", "frmSocks", "frmDebugSC"
42:                     Unload frmLoop
43:             End Select
44:        Next

46:        Set frmLoop = Nothing

       #If LUA Then
49:        If Not g_colLua Is Nothing Then
50:            For Each g_objLua In g_colLua
51:                g_objLua.Dispose
52:                Set g_objLua = Nothing
53:            Next
54:        End If
       #End If
        
57:        Set g_colSWinsocks = Nothing
58:        Set g_colSVariables = Nothing
59:    Else
60:        blnLoaded = True
61:    End If
 
63:    Set g_colSWinsocks = New Collection
64:    Set g_colSVariables = New Collection
65:    Set g_objDebugSC = New frmDebugSC
   #If LUA Then
67:    Set g_colLua = New Collection
   #End If
69:    Call Load(g_objDebugSC)

71:    Call frmHub.NewTimersAPI
       
       'Clear listview and tab strip
74:    frmHub.lvwScripts.ListItems.Clear
75:    frmHub.tbsScripts.Tabs.Clear

       'Resize/clear out event array
78:    frmHub.SResizeArrEvent 1, False
    
       'If not found scripts..
81:    If Not FoundScripts Then
82:        g_objFileAccess.WriteFile G_APPPATH & "\Scripts\" & g_colMessages.Item("msgNewScript") & ".vbs", n_sDefScript
83:    End If

       'Get first file handle
86:    lngOne = FindFirstFile(G_APPPATH & "\Scripts\*.*", WFD)
    
       'If it doesn't equal -1, then there are files
89:    If Not lngOne = -1 Then

91:        Do Until lngTwo = 18&

               'Can't be a directory
94:            If Not (WFD.dwFileAttributes And &H10) = vbDirectory Then

                    'Extract file name
97:                 lngTwo = InStrB(1, WFD.cFileName, vbNullChar)
                
99:                 If lngTwo Then _
                         strTemp = LeftB$(WFD.cFileName, lngTwo) _
                    Else strTemp = WFD.cFileName
                    
103:                 lngTwo = InStrRev(strTemp, ".")
                
                    'Check extension and determine language
                    Select Case Mid$(strTemp, lngTwo + 1)
                        Case "vbs", "script": strLanguage = "VBScript"
                        Case "js": strLanguage = "JScript"
'                       Case "pl": strLanguage = "PerlScript"
                    #If LUA Then
                        Case "lua": strLanguage = "Lua"
                    #End If
                        Case Else: GoTo NextLoop
109:                End Select
 
                    'Increment count
112:                intIndex = intIndex + 1
                    
                    'Load new code editor.. and add new item to listview
115:                Call LvwAddItem(intIndex, strTemp, strLanguage)
116:                Call AddNewCodeEditor(intIndex, strTemp, strLanguage)
                    
                   'Load objects
119:                Load frmHub.ScriptControl(intIndex)
120:                Load frmHub.tmrScriptTimer(intIndex)

                    'Get scriptcontrol
123:                Set objSC = frmHub.ScriptControl(intIndex)

               #If LUA Then
126:               If strLanguage = "Lua" Then
127:                    objSC.Tag = "Lua"
128:                    Set g_objLua = New NetLink.LuaLink
129:                    If g_objLua.LoadPlug(frmHub) = 1 Then
130:                        g_objLua.Name = strTemp
131:                        g_objLua.Index = intIndex
132:                        g_colLua.Add g_objLua, CStr(intIndex)
133:                    End If
134:                Else
               #End If
                       'Load winsock collection
137:                    Set frmWS = New frmSocks
138:                    Set frmWS.Script = objSC
    
140:                    frmWS.Tag = CStr(intIndex)
141:                    g_colSWinsocks.Add frmWS, CStr(intIndex)
                        
                       'Load static var dictionary
144:                    Set objSV = New clsDictionary
145:                    g_colSVariables.Add objSV, CStr(intIndex)
        
                        'Set settings
148:                    objSC.Tag = strTemp
149:                    objSC.Language = strLanguage
150:                    objSC.Timeout = g_objSettings.ScriptTimeout
151:                    objSC.UseSafeSubset = g_objSettings.ScriptSafeMode
               #If LUA Then
153:               End If
               #End If
155:           End If
156:
NextLoop:
               'Get next file
158:           lngTwo = FindNextFile(lngOne, WFD)
        
               'Exit if it's zero
161:           If lngTwo = 0 Then Exit Do

163:        Loop

165:        If blnLoaded Then
166:            LockWindowUpdate 0
167:        End If

           'Redim array if needed
            Select Case intIndex
                Case 0, 1
                Case Else
170:               frmHub.SResizeArrEvent intIndex, False
171:        End Select
            
173:   End If
      
175:   Exit Sub
    
177:
Err:
178:   HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.SLoadDir()"
End Sub
Public Sub SLoadScript(ByVal strName As String)
1:     Dim objSC           As ScriptControl
2:     Dim frmWS           As frmSocks
3:     Dim objSV           As clsDictionary
4:     Dim frmLoop         As Form

6:     Dim intIndex        As Integer
7:     Dim strLanguage     As String
8:     Dim lngTwo As Long

10:    On Error GoTo Err

12:    If frmHub.ScriptControl.UBound <> 0 Then
13:       intIndex = (frmHub.ScriptControl.UBound + 1)
14:    Else
15:       intIndex = 1
16:    End If
       
       'Check extension and determine language
19:    If Right(strName, 3) = "vbs" Or Right(strName, 6) = "script" Then
20:         strLanguage = "VBScript"
21:    ElseIf Right(strName, 2) = "js" Then
22:         strLanguage = "JScript"
'      ElseIf Right(strName, 2) = "pl" Then
'         strLanguage = "PerlScript"
   #If LUA Then
25:    ElseIf Right(strName, 3) = "lua" Then
26:         strLanguage = "Lua"
   #End If
28:    Else
29:         Exit Sub
30:    End If

31:    Call LvwAddItem(intIndex, strName, strLanguage)
32:    Call AddNewCodeEditor(intIndex, strName, strLanguage)
                    
       'Load objects
35:    Load frmHub.ScriptControl(intIndex)
36:    Load frmHub.tmrScriptTimer(intIndex)
                    
       'Get scriptcontrol
39:    Set objSC = frmHub.ScriptControl(intIndex)

   #If LUA Then
41:    If strLanguage = "Lua" Then
42:        objSC.Tag = "Lua"
43:        Set g_objLua = New NetLink.LuaLink
44:        If g_objLua.LoadPlug(frmHub) = 1 Then
45:            g_objLua.Name = strName
46:            g_objLua.Index = intIndex
47:            g_colLua.Add g_objLua, CStr(intIndex)
48:        End If
49:    Else
   #End If
   
           'Load winsock collection
51:        Set frmWS = New frmSocks
52:        Set frmWS.Script = objSC
    
54:        frmWS.Tag = CStr(intIndex)
55:        g_colSWinsocks.Add frmWS, CStr(intIndex)
                        
           'Load static var dictionary
58:        Set objSV = New clsDictionary
59:        g_colSVariables.Add objSV, CStr(intIndex)
        
           'Set settings
61:        objSC.Tag = strName
62:        objSC.Language = strLanguage
63:        objSC.Timeout = g_objSettings.ScriptTimeout
64:        objSC.UseSafeSubset = g_objSettings.ScriptSafeMode
    
66:        If frmHub.ScriptControl.UBound <> 1 Or frmHub.ScriptControl.UBound <> 0 Then
67:            frmHub.SResizeArrEvent intIndex, False
68:        Else
69:            frmHub.SResizeArrEvent intIndex, True
70:        End If

   #If LUA Then
71:    End If
   #End If
   
73:    Exit Sub
    
75:
Err:
76:   HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.SLoadScript(" & strName & ")"
End Sub
Public Sub SSave(Optional ByVal intIndex As Integer = 0)
1:    Dim strTemp       As String
2:    Dim lngSelected   As Long
3:    Dim intSC      As Integer
4:    On Error GoTo Err

6:    With frmHub

8:       If intIndex = 0 Then
              'Save selected
10:           lngSelected = .IsListViewSelected(.lvwScripts)
11:           If lngSelected <> -1 Then
12:                intSC = CInt(.lvwScripts.ListItems(lngSelected).Tag)
13:                strTemp = g_objSciLexer(intSC).Text
14:                .tbsScripts.Tabs(intSC).Tag = strTemp
15:                g_objFileAccess.WriteFile G_APPPATH & "\Scripts\" & .tbsScripts.Tabs(intSC).Key, strTemp
                   '
17:                g_objSciLexer(intSC).ClearUndoBuffer
18:           End If
19:       Else
              'Save by Index
21:           strTemp = g_objSciLexer(intIndex).Text
              '
23:           .tbsScripts.Tabs(intIndex).Tag = strTemp
24:           g_objFileAccess.WriteFile G_APPPATH & "\Scripts\" & .tbsScripts.Tabs(intIndex).Key, strTemp
              '
26:           g_objSciLexer(intIndex).ClearUndoBuffer
27:       End If
          
29:   End With

31:   Exit Sub
32:
Err:
33:   HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.SSave(" & intIndex & ")"
End Sub
Public Sub SResetByName(ByVal strName As String, Optional ByVal blnUpDateCode As Boolean = True, Optional ByVal blnFirst As Boolean)
1:    Dim intIndex    As Integer
2:    Dim strTemp     As String
3:    Dim intSC       As Integer
4:    On Error GoTo Err

6:    With frmHub
    
8:         For intIndex = 1 To .lvwScripts.ListItems.count
9:            If .lvwScripts.ListItems(intIndex).Text = strName Then
10:                intSC = CInt(.lvwScripts.ListItems(intIndex).Tag)
11:                If blnUpDateCode Then .tbsScripts.Tabs(intSC).Tag = g_objSciLexer(intSC).Text
12:                If SetSReset(intSC, .ScriptControl(intSC), blnFirst) Then
13:                     If blnUpDateCode Then Call SSave(intSC)
14:                End If
15:                Exit Sub
16:            End If
17:        Next
    
19:   End With
    
21:   Exit Sub
    
23:
Err:
24:   HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.SResetByName(" & strName & ")"
End Sub

'Reset script.. only update the scripts to file, if no errors
Public Sub SReset(Optional ByVal lngSel As Long, Optional ByVal blnUpDateCode As Boolean = True, Optional ByVal blnFirst As Boolean)
1:    Dim intIndex    As Integer
2:    Dim strTemp     As String
3:    Dim lngSelected As Long
4:    Dim intSC      As Integer
5:    On Error GoTo Err
    
7:    With frmHub
                        
       Select Case lngSel
        
            '*********************************************
            Case -2 'All checked scripts
            '*********************************************
            
13:                 For intIndex = 1 To .lvwScripts.ListItems.count
14:                     If .lvwScripts.ListItems(intIndex).Checked Then
15:                         intSC = CInt(.lvwScripts.ListItems(intIndex).Tag)
16:                         If blnUpDateCode Then .tbsScripts.Tabs(intSC).Tag = g_objSciLexer(intSC).Text
17:                         If SetSReset(intSC, .ScriptControl(intSC), blnFirst) Then
18:                                If blnUpDateCode Then Call SSave(intSC)
19:                         End If
20:                     End If
21:                 Next

            '*********************************************
            Case -1 'All scripts
            '*********************************************

26:                 For intIndex = 1 To .lvwScripts.ListItems.count
27:                     intSC = CInt(.lvwScripts.ListItems(intIndex).Tag)
28:                     If blnUpDateCode Then .tbsScripts.Tabs(intSC).Tag = g_objSciLexer(intSC).Text
29:                     If SetSReset(intSC, .ScriptControl(intSC), blnFirst) Then
30:                            If blnUpDateCode Then Call SSave(intSC)
31:                     End If
32:                 Next
            
            '*********************************************
            Case 0 'Selected script
            '*********************************************
            
37:                lngSelected = .IsListViewSelected(.lvwScripts)
38:                If lngSelected <> -1 Then
39:                    intSC = CInt(.lvwScripts.ListItems(intIndex).Tag)
40:                    If blnUpDateCode Then .tbsScripts.Tabs(intSC).Tag = g_objSciLexer(intSC).Text
41:                    If SetSReset(intSC, .ScriptControl(intSC), blnFirst) Then
42:                         If blnUpDateCode Then Call SSave(intSC)
43:                    End If
44:                End If

            '*********************************************
            Case Is > 0 ' by Index
            '*********************************************

49:               If blnUpDateCode Then .tbsScripts.Tabs(lngSel).Tag = g_objSciLexer(lngSel).Text
50:               If SetSReset(CInt(lngSel), .ScriptControl(CInt(lngSel)), blnFirst) Then
51:                     If blnUpDateCode Then Call SSave(CInt(lngSel))
52:               End If
                  
54:        End Select
        
56:   End With
    
58:   Exit Sub
    
60:
Err:
61:   HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.SReset(" & lngSel & ")"
End Sub

Public Sub SStopByName(ByVal strName As String)
1:    Dim intIndex  As Integer
2:    Dim strTemp   As String
3:    Dim intSC     As Integer
    
5:    On Error GoTo Err

7:    With frmHub
    
9:         For intIndex = 1 To .lvwScripts.ListItems.count
10:            If .lvwScripts.ListItems(intIndex).Text = strName Then
11:                 intSC = CInt(.lvwScripts.ListItems(intIndex).Tag)
12:                 SetSStop intSC, .ScriptControl(intSC)
13:                 Exit Sub
14:            End If
15:        Next
    
17:   End With
    
19:   Exit Sub
    
21:
Err:
22:   HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.SStopByName(" & strName & ")"
End Sub

Public Sub SStop(Optional ByVal lngSel As Long)
1:    Dim intIndex      As Integer
2:    Dim lngSelected   As Long
3:    Dim intSC         As Integer
        
5:    On Error GoTo Err
    
7:    With frmHub

       Select Case lngSel
        
            '*********************************************
            Case -2 'All checked scripts
            '*********************************************

13:                 For intIndex = 1 To .lvwScripts.ListItems.count
14:                     If .lvwScripts.ListItems(intIndex).Checked Then
15:                         intSC = CInt(.lvwScripts.ListItems(intIndex).Tag)
                            'Stop script..
17:                         SetSStop intSC, .ScriptControl(intSC)
18:                     End If
19:                 Next

            '*********************************************
            Case -1 'All scripts
            '*********************************************
            
24:                 For intIndex = 1 To .lvwScripts.ListItems.count
25:                     intSC = CInt(.lvwScripts.ListItems(intIndex).Tag)
                        'Stop script..
27:                     SetSStop intSC, .ScriptControl(intSC)
28:                 Next
                
            '*********************************************
            Case 0 'Selected script
            '*********************************************

33:                 lngSelected = .IsListViewSelected(.lvwScripts)
34:                 If lngSelected <> -1 Then
35:                     intSC = CInt(.lvwScripts.ListItems(intIndex).Tag)
                        'Stop script..
37:                     SetSStop intSC, .ScriptControl(intSC)
38:                 End If

            '*********************************************
            Case Is > 0 ' by Index
            '*********************************************
                   
                   'Stop script..
44:                SetSStop lngSel, .ScriptControl(CInt(lngSel))

46:        End Select

48:   End With

50:   Exit Sub
    
52:
Err:
53:   HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.SStop(" & lngSel & ")"
End Sub

Private Sub SetSStop(ByVal intIndex As Integer, objSC As ScriptControl)
1:    On Error Resume Next
      
 #If LUA Then
3:   If objSC.Tag = "Lua" Then
4:      Set g_objLua = g_colLua.Item(CStr(objSC.Index))
5:      g_objLua.UnloadMain
6:      g_objLua.Reset
7:   Else
 #End If
 
        'Raise UnloadMain() event
9:      objSC.Run "UnloadMain"
    
        'Reset all code/objects
14:      objSC.Reset
    
        'Set script event enabled status' to false
17:      frmHub.SClearEvents intIndex

  #If LUA Then
18:   End If
  #End If
    
20:   On Error GoTo Err
        
      'Uncheck listitem
21:   With frmHub.lvwScripts
22:        If .ListItems(intIndex & "s").Checked Then _
                .ListItems(intIndex & "s").Checked = False
24:        .ListItems(intIndex & "s").SubItems(1) = "Inactive"
25:        .ListItems(intIndex & "s").SubItems(3) = Now
26:        frmHub.AddScriptLog .ListItems(intIndex & "s").Text, "Script stopped"
27:   End With
      
      
28:    Exit Sub

30:
Err:
31:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.SetSStop(" & intIndex & ")"
End Sub

Private Sub AddNewCodeEditor(ByVal intIndex As Integer, _
                             ByVal strName As String, _
                             ByVal strLanguage As String)
3:     On Error GoTo Err

5:     Dim strTemp  As String, strTemp2 As String

7:     ReDim Preserve g_objSciLexer(intIndex)
            
9:     Set g_objSciLexer(intIndex) = New clsYScintilla

11:    strTemp = g_objFileAccess.ReadFile(G_APPPATH & "\Scripts\" & strName)
        
13:    Load frmHub.picSciMain(intIndex)

       Select Case intIndex
            Case 1: frmHub.picSciMain(intIndex).Visible = True
            Case Else: frmHub.picSciMain(intIndex).Visible = False
15:    End Select

17:    If Len(strName) > 16 Then _
            strTemp2 = Left(strName, 14) & ".." _
       Else strTemp2 = strName

21:    frmHub.tbsScripts.Tabs.Add (intIndex), strName, strTemp2
22:    frmHub.tbsScripts.Tabs(intIndex).Tag = strTemp
         
24:    g_objSciLexer(intIndex).CreateScintilla frmHub.picSciMain(intIndex)

26:    g_objSciLexer(intIndex).SetFixedFont "Courier New", 10
        
       'Give the scrollbar a nice long width to
       'handle a long line which may occur.
30:    g_objSciLexer(intIndex).ScrollWidth = 10000
       'This is absolutly an imperative line
32:    g_objSciLexer(intIndex).Attach frmHub.picSciMain(intIndex)
33:    g_objSciLexer(intIndex).Folding = True
34:    g_objSciLexer(intIndex).LineNumbers = True
35:    g_objSciLexer(intIndex).AutoIndent = True
36:    g_objSciLexer(intIndex).SetMarginWidth MarginLineNumbers, 50
37:    g_objSciLexer(intIndex).ContextMenu = True
38:    g_objSciLexer(intIndex).LineBreak = SC_EOL_CRLF
39:    g_objSciLexer(intIndex).SetTabWidth 4

41:    Call g_objHighlighter.SetHighlighterBasedOnExt(g_objSciLexer(intIndex), strName)

43:    g_objSciLexer(intIndex).Text = strTemp
            
45:    frmHub.tbsScripts.ZOrder vbSendToBack
       
47:    frmHub.Form_Resize

49:    g_objSciLexer(intIndex).ClearUndoBuffer
       
51:    Exit Sub
52:
Err:
53:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.AddNewCodeEditor(" & intIndex & ")"
End Sub

Public Sub SProperties(ByRef strIndex As String, _
                       ByRef strName As String, _
                       ByRef lngType As Long)

4:    Dim frmProp As Form
5:    Dim Modal As Byte

7:    Dim sFile As String
8:    Dim sXML As String

10:    On Error GoTo Err
    
      'If *.xml file properties not found, create on new..
13:     sFile = G_APPPATH & "\Scripts\" & (LeftB(strName, InStrB(1, strName, ".") - 1) & ".xml")
14:     If Not g_objFileAccess.FileExists(sFile) Then
15:         sXML = _
            "<Properties>" & vbNewLine & _
            vbTab & "<Author></Author>" & vbNewLine & _
            vbTab & "<Copyright></Copyright>" & vbNewLine & _
            vbTab & "<Version></Version>" & vbNewLine & _
            vbTab & "<Website></Website>" & vbNewLine & _
            vbTab & "<Description></Description>" & vbNewLine & _
            vbTab & "<Comments></Comments>" & vbNewLine & _
            "</Properties>"
24:         g_objFileAccess.WriteFile (sFile), sXML
25:     Else 'if found
           'Loop through to find if the form exists
27:         For Each frmProp In Forms
               'Check to see if it's the right kind of form
29:            If frmProp.Name = "frmProperties" Then
30:               If frmProp.Tag = strIndex Then
                     'Set focus
32:                  frmProp.SetFocus
33:                  Set frmProp = Nothing
34:                  Exit Sub
35:               End If
36:            End If
37:         Next
38:     End If
        'We haven't found a form and must create one
40:     Set frmProp = New frmProperties

42:     frmProp.Tag = strIndex
43:     frmProp.PType = lngType
44:     frmProp.file = strName

        'Set Full Selected Rum
47:     LVFullRow frmProp.lvwProperties.hwnd
48:     frmProp.stBar.Panels(1).Text = strName
        
        ' hook window for sizing control
        ' Disable the following line if you will be debugging form.
52:     Call HookWin(frmProp.hwnd, G_PrWnd)

54:     frmProp.Show Modal, frmHub
    
56:  Exit Sub
    
58:
Err:
59:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.PSLoad()"
End Sub
Public Sub XmlBooleanLoad()
1:   Dim objXML           As clsXMLParser
2:   Dim objNode          As clsXMLNode
3:   Dim colNodes         As Collection
4:   Dim colSubNodes      As Collection
5:   Dim strTemp          As String
6:   Dim iIndex           As Integer
7:   Dim lvwItem          As Variant
8:   Dim strKey           As String
9:   Dim i                As Integer
10:   On Error GoTo Err

12:    Set objXML = New clsXMLParser
 
14:    strTemp = G_APPPATH & "\Settings\Scripts.xml"

16:    If g_objFileAccess.FileExists(strTemp) Then
         
18:       objXML.Data = g_objFileAccess.ReadFile(strTemp)
19:       objXML.Parse

21:       Set colNodes = objXML.Nodes(1).Nodes
       
23:       On Error Resume Next
24:       For Each objNode In colNodes
25:            Set colSubNodes = objNode.Attributes
            
27:            With frmHub.lvwScripts
28:                For i = 1 To .ListItems.count
29:                   If .ListItems(i).Text = CStr(colSubNodes("Name").Value) Then
30:                        .ListItems(i).Checked = CBool(colSubNodes("Value").Value)
31:                        iIndex = CInt(colSubNodes("Index").Value)
32:                        If (i > 0) And (i <= .ListItems.count) And (Not i = iIndex) Then
33:                            Set lvwItem = .ListItems.Add(iIndex, , .ListItems(i).Text)
34:                            lvwItem.SubItems(1) = .ListItems(i + 1).SubItems(1)
35:                            lvwItem.SubItems(2) = .ListItems(i + 1).SubItems(2)
36:                            lvwItem.SubItems(3) = .ListItems(i + 1).SubItems(3)
37:                            lvwItem.Checked = .ListItems(i + 1).Checked
38:                            lvwItem.Tag = .ListItems(i + 1).Tag
39:                            strKey = .ListItems(i + 1).Key
                               '
41:                            .ListItems.Remove (i + 1)
42:                            lvwItem.Key = strKey
43:                        End If
44:                        Exit For
45:                   End If
46:                Next
47:            End With
            
49:       Next

51:       On Error GoTo Err
    
53:       objXML.Clear
    
55:       Set objNode = Nothing
56:       Set colSubNodes = Nothing
57:       Set colNodes = Nothing
       
59:       Set lvwItem = Nothing

61:   End If

63:   Exit Sub
    
65:
Err:
66:   HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.XmlBooleanLoad()"
End Sub
Public Sub XmlBooleanSave()
1:    On Error GoTo Err
2:    Dim intFF       As Integer
3:    Dim strTemp     As String
4:    Dim i           As Integer

    'Save Scripts Values (Checked/UnChecked and Index)
7:    strTemp = G_APPPATH & "\Settings\Scripts.xml"

9:    If g_objFileAccess.FileExists(strTemp) Then g_objFileAccess.DeleteFile strTemp
 
11:    intFF = FreeFile

13:    Open strTemp For Append As intFF
14:      Print #intFF, vbXML
15:      Print #intFF, "<Scripts>"
16:        With frmHub.lvwScripts
17:            For i = 1 To .ListItems.count
18:                 Print #intFF, vbTab & "<Script Name=""" & .ListItems(i).Text & """" & _
                                                " Value=""" & .ListItems(i).Checked & """" & _
                                                " Index=""" & i & """ />"
21:            Next
22:        End With
23:      Print #intFF, "</Scripts>";
24:    Close intFF
    
26:   Exit Sub
    
28:
Err:
29:   HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.XmlBooleanSave()"
End Sub

Private Function SSPrereset(ByRef objSC As ScriptControl, _
                            ByRef strRead As String, _
                            ByRef strWrite As String, _
                            ByRef blnVBScript As Boolean) As String
    '------------------------------------------------------------------
    'Purpose:   To perform preprocessing commands given by the script,
    '           which are denoted by the symbol # or @
    '
    'Params:
    '           objSC:          Reference to script's control object
    '           strRead:        Path to script input file
    '           strWrite:       Path to script output file (generated if
    '                           not given) where code with the preprocessor
    '                           instructions are interpreted
    '           blnVBScript:    Toggles if language is VBScript or JScript
    '
    'Returns:
    '           strWrite (if it was given, it returns the same as the
    '           given path, otherwise it returns the path to the
    '           temporary file generated)
    '------------------------------------------------------------------
    
22:    Dim intRead         As Integer
23:    Dim intWrite        As Integer
24:    Dim intFlag         As Integer
    
26:    On Error GoTo Err
    
    'If VBScript, we search for #
    'If JScript, we search for @
30:    If blnVBScript Then
31:        intFlag = CHR_SHARP
32:    Else
33:        intFlag = CHR_AT
34:    End If
    
    'Open script for reading
37:    intRead = FreeFile
38:    Open strRead For Binary Access Read Lock Read Write As intRead
    
    'Create temporary file for appending to
41:    intWrite = FreeFile
    
43:    If StrPtr(strWrite) Then
44:        If LenB(Dir(strWrite)) Then
45:            Kill strWrite
46:        End If
47:    Else
48:        strWrite = GenTempFile()
49:    End If
        
51:    Open strWrite For Append Lock Read Write As intWrite
    
    'Begin preprocessing
54:    Preproc intRead, intWrite, intFlag, objSC
    
    'Close file handles
57:    Close intRead
58:    Close intWrite
    
    'Return path to code
61:    SSPrereset = strWrite
    
63:    Exit Function
    
65:
Err:
66:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.SSPrereset(, """ & strRead & """, """ & strWrite & """, " & blnVBScript & ")"
End Function

Private Sub ParseIf(ByVal intRead As Integer, _
                    ByVal intWrite As Integer, _
                    ByVal intChar As Integer, _
                    ByRef strExp As String, _
                    ByRef objSC As ScriptControl)
    '------------------------------------------------------------------
    'Purpose:   To interpret the preprocessor command #If, #ElseIf
    '           #Else and #End If.
    '
    '           #If/etc works just like their counterparts without
    '           the # except for one difference; the boolean expression
    '           is only ever evaluated once before starting the script.
    '           The code included in the script is for whichever
    '           statement for the #Ifs/ElseIfs evaluates to true first
    '           or the code for #Else if all are false and it is
    '           included.
    '
    '           Example:
    '               #If <expression> Then
    '                   'Include code for this exp
    '               #ElseIf <expression> Then
    '                   'If the first wasn't true, try this
    '               #Else
    '                   'Alright neither was true, include this code
    '               #End If
    '
    'Params:
    '           intRead:        File handle on input for the script code
    '           intWrite:       File handle on file to output parsed
    '                           code to
    '           intChar:        Character which denotes a preprocessor
    '                           command (#/@)
    '           strExp:         Expression which is to be evaluated
    '                           to determine if the code is to be
    '                           included or skipped (includes #If
    '                           and trailing Then)
    '           objSC:          Script's control object
    '------------------------------------------------------------------
    
39:    Dim strLine     As String
40:    Dim intCount    As Integer
41:    Dim intRet      As Integer
    
43:    On Error GoTo Err
    
    'Set count of totatal #End If to 1
46:    intCount = 1
    
    'Trim out expression to evaluate
49:    strExp = MidB$(strExp, 9, LenB(strExp) - 19)
    
    'Get a boolean out of it
52:    intRet = CBool(objSC.Eval(strExp))
    
    'Keep looping until we get a flag to exit
    'In other words, keep looping until we find an #If or #ElseIf which
    'evaluates to true, an #Else which is always true, or an #End If
57:    Do Until intRet Or EOF(intRead)
        'Make sure we don't pass the file boundaries
59:        Do Until EOF(intRead)
            'Take in a line and trim
61:            Line Input #intRead, strLine
62:            strLine = TrueTrim(strLine)
            
            'Skip null lines
65:            If LenB(strLine) Then
                'If it is a preproc command, everything is fine and dandy
67:                If AscW(strLine) = intChar Then
                    'Ignore #Include, #If, #Library, etc because this part of the
                    'code block is being ignored anyways
                    Select Case PreProcCmd(strLine, intChar)
                        Case PPC_IF
70:                            intCount = intCount + 1
                        Case PPC_ELSEIF
                            'Another expression to parse out and check
72:                            intRet = CBool(objSC.Eval(MidB$(strLine, 17, LenB(strLine) - 27)))
73:                            Exit Do
                        Case PPC_ELSE
                            '#Else means everything else failed and we must use this block
75:                            intRet = -1
76:                            Exit Do
                        Case PPC_ENDIF
77:                            intCount = intCount - 1
                            
79:                            If intCount = 0 Then
                                'Nothing left to the #If; we're done
81:                                intRet = 1
82:                                Exit Do
83:                            End If
84:                    End Select
85:                End If
86:            End If
87:        Loop
88:    Loop
    
    'Continue beyond this point only if there is a code block to include
91:    If intRet = -1 Then
        'Make sure we don't pass the file boundaries
93:        Do Until EOF(intRead)
            'Read line and trim whitespace
95:            Line Input #intRead, strLine
96:            strLine = TrueTrim(strLine)
            
            'Skip null lines
99:            If LenB(strLine) Then
                'Preproc command?
101:                If AscW(strLine) = intChar Then
                    'If so, check the type; now we must parse all of them
                    'because this is code we want to include in the script
    
                    'Another note is that we shouldn't parse any preproc commands
                    'if they are inside other blocks - hence the reason for the
                    'intRet checks
                    Select Case PreProcCmd(strLine, intChar)
                        Case PPC_LIBRARY
108:                            If intRet Then
109:                                ParseLibrary strLine, objSC
110:                            End If
                        Case PPC_INCLUDE
111:                            If intRet Then
112:                                ParseInclude intRead, intWrite, intChar, strLine, objSC
113:                            End If
                        Case PPC_CONST
114:                            If intRet Then
115:                                ParseConst intWrite, strLine, objSC
116:                            End If
                        Case PPC_IF
117:                            If intRet Then
118:                                ParseIf intRead, intWrite, intChar, strLine, objSC
119:                            End If
                        Case PPC_ELSEIF, PPC_ELSE
                            'If we've found an #ElseIf or #Else, that means we have
                            'to trim the rest of the #If/#End If block out before
                            'finishing up
123:                            intRet = 0
                        Case PPC_ENDIF
                            'Found the end of the block; exit out of the loop
125:                            Exit Do
126:                    End Select
127:                Else
                    'Only add code to script if we are in the block we want to keep
129:                    If intRet = -1 Then
130:                        Print #intWrite, strLine
131:                    End If
132:                End If
133:            Else
134:                If intRet = -1 Then
135:                    Print #intWrite, ""
136:                End If
137:            End If
138:        Loop
139:    End If

141:    Exit Sub
    
143:
Err:
144:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.ParseIf(" & intRead & ", " & intWrite & ", " & intChar & ", """ & strExp & """, )"
End Sub

Private Sub Preproc(ByVal intRead As Integer, _
                    ByVal intWrite As Integer, _
                    ByVal intChar As Integer, _
                    ByRef objSC As ScriptControl)
    '------------------------------------------------------------------
    'Purpose:   Searches for preprocessing commands in code and
    '           then calls the appropriate function to process
    '           any commands it finds
    '
    'Params:
    '           intRead:        File handle on input for the script code
    '           intWrite:       File handle on file to output parsed
    '                           code to
    '           intChar:        Character which denotes a preprocessor
    '                           command (#/@)
    '           objSC:          Script's control object
    '
    'Returns:
    '           Copy of strString without trailing/leading whitespace
    '------------------------------------------------------------------
    
21:    Dim strLine         As String
    
23:    On Error GoTo Err
    
    'Do until the end of the file is reached
26:    Do Until EOF(intRead)
        'Read line and trim whitespace
28:        Line Input #intRead, strLine
29:        strLine = TrueTrim(strLine)
        
        'Skip empty lines
32:        If LenB(strLine) Then
            'Is it a preproc command?
34:            If AscW(strLine) = intChar Then
                'Find out!
                Select Case PreProcCmd(strLine, intChar)
                    Case PPC_INCLUDE
36:                        ParseInclude intRead, intWrite, intChar, strLine, objSC
                    Case PPC_LIBRARY
37:                        ParseLibrary strLine, objSC
                    Case PPC_CONST
38:                        ParseConst intWrite, strLine, objSC
                    Case PPC_IF
39:                        ParseIf intRead, intWrite, intChar, strLine, objSC
                    Case PPC_ELSE, PPC_ELSEIF, PPC_ENDIF
                        'Orphaned statements it appears; just ignore 'em
41:                End Select
42:            Else
                'Just a regular line of code then; write to document
44:                Print #intWrite, strLine
45:            End If
46:        Else
47:            Print #intWrite, ""
48:        End If
49:    Loop
    
51:    Exit Sub
    
53:
Err:
    'Just to keep Error.txt clean because of
    '<Line Input> bug if last line of file is empty
    '"Input past end of file"
'    If (LCase(strLine) = "end sub") Or (LCase(strLine) = "end function") Or (strLine = "") Then _
'        Exit Sub
59:    If Err.Number = 62 Then Exit Sub
    
61:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.Preproc(" & intRead & ", " & intWrite & ", " & intChar & ", """ & strLine & """, )"
End Sub

Private Function PreProcCmd(ByRef strLine As String, _
                            ByVal intChar As Integer) As Integer
    '------------------------------------------------------------------
    'Purpose:   To check if the line starting with intChar is a valid
    '           preproc command, and if it is, to confirm that it has
    '           the proper form
    '
    'Params:
    '           strLine:        Line of code to evaluate to check if
    '                           it is a valid preprocessor command
    '           intChar:        Character which denotes a preproc command
    '
    'Returns:
    '           0 if it is not a valid command, otherwise it returns
    '           a unique numerical code denoting the type of command
    '           that we have
    '------------------------------------------------------------------
    
18:    Dim strTemp     As String
19:    Dim lngPos      As Long
    
21:    On Error GoTo Err
    
    'Set to all lower case
24:    strTemp = MidB$(LCase$(strLine), 3)
    
    'Pretty straight forward...#Else and #End If
    'are the only 2 commands thus far without any parameters
    'so check them first
29:    If strTemp = "end if" Then
30:        PreProcCmd = PPC_ENDIF
31:    ElseIf strTemp = "else" Then
32:        PreProcCmd = PPC_ELSE
33:    Else
        'OK, not either of those, extract first word
35:        lngPos = InStrB(1, strTemp, " ")
        
        'Make sure there is a word to extract
38:        If lngPos Then
            Select Case LeftB$(strTemp, lngPos - 1)
                Case "const"
39:                    PreProcCmd = PPC_CONST
                Case "if"
                    '#If has to end in " Then" to be valid
41:                    If RightB$(strTemp, 10) = " then" Then
42:                        PreProcCmd = PPC_IF
43:                    End If
                Case "elseif"
                    '#ElseIf has to end in " Then" to be valid
45:                    If RightB$(strTemp, 10) = " then" Then
46:                        PreProcCmd = PPC_ELSEIF
47:                    End If
                Case "include"
                    '#Include must have "" surrounding the path
49:                    If AscW(MidB$(strTemp, lngPos + 2)) = CHR_DQUOTE Then
50:                        If AscW(RightB$(strTemp, 2)) = CHR_DQUOTE Then
51:                            PreProcCmd = PPC_INCLUDE
52:                        End If
53:                    End If
                Case "library"
                    '#Library must have "" surrounding the name
55:                    If AscW(MidB$(strTemp, lngPos + 2)) = CHR_DQUOTE Then
56:                        If AscW(RightB$(strTemp, 2)) = CHR_DQUOTE Then
57:                            PreProcCmd = PPC_INCLUDE
58:                        End If
59:                    End If
60:            End Select
61:        End If
62:    End If
    
    'Confirm that the command we found
65:    If intChar = CHR_SHARP Then
66:        If (PreProcCmd And PPC_VBSCRIPT) = 0 Then
67:            PreProcCmd = 0
68:        End If
69:    Else
70:        If (PreProcCmd And PPC_JSCRIPT) = 0 Then
71:            PreProcCmd = 0
72:        End If
73:    End If
    
75:    Exit Function
    
77:
Err:
78:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.PreProcCmd(""" & strLine & """, " & intChar & ")"
End Function

Private Sub ParseConst(ByVal intWrite As Integer, _
                       ByRef strLine As String, _
                       ByRef objSC As ScriptControl)
    '------------------------------------------------------------------
    'Purpose:   To parse a preproc constant and add it to the script's
    '           control object to allow expressions to use it (#If,If,
    '           etc)
    '
    '           Format:
    '               #Const <name> = <value>
    '               #Const MYCONST = "this is a constant!!!"
    '               #Const MYNUM = 453
    '
    'Params:
    '           intWrite:       File handle on file to output parsed
    '                           code to
    '           strLine:        Code to extract constant from
    '           objSC:          Script's control object
    '------------------------------------------------------------------
    
20:    On Error GoTo Err
    
    'Add blank line to script to make line numbers more accurate
23:    Print #intWrite, ""
    
    'Create constant
26:    objSC.ExecuteStatement MidB$(strLine, 3)
    
28:    Exit Sub
    
30:
Err:
31:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.ParseConst(" & intWrite & ", """ & strLine & """, )"
End Sub

Private Sub ParseInclude(ByVal intRead As Integer, _
                         ByVal intWrite, _
                         ByVal intChar As Integer, _
                         ByRef strLine As String, _
                         ByRef objSC As ScriptControl)
    '------------------------------------------------------------------
    'Purpose:   To parse an #Include statement, which includes code
    '           from another file and inserts it into the script.
    '           Since the included code might contain preproc
    '           commands as well, we must start the process again
    '           for this as well (call to Preproc)
    '
    '           Base directory is the DDCH installation folder
    '
    '           Format:
    '               #Include "<path_to_file>"
    '               #Include "\Scripts\Includes\header.vbs"
    '
    'Params:
    '           intRead:        File handle on input for the script code
    '           intWrite:       File handle on file to output parsed
    '                           code to
    '           intChar:        Character which denotes a preproc command
    '           strLine:        Code to extract constant from
    '           objSC:          Script's control object
    '------------------------------------------------------------------
    
27:    Dim intIR       As Integer
    
29:    On Error GoTo Err
    
    'Open the file for reading
32:    intIR = FreeFile
33:    Open G_APPPATH & "\" & MidB$(strLine, 21, LenB(strLine) - 23) For Binary Access Read Lock Read Write As intIR
    
    'Begin preproc on the external code if any
36:    Preproc intIR, intWrite, intChar, objSC
    
    'Close file
39:    Close intIR
    
41:    Exit Sub
    
43:
Err:
44:    HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.ParseInclude(" & intRead & ", " & intWrite & ", " & intChar & ", """ & strLine & """, )"
End Sub

Private Sub ParseLibrary(ByRef strLib As String, _
                         ByRef objSC As ScriptControl)
'
End Sub

Private Function FoundScripts() As Boolean
1:    Dim strScript() As String
2:    Dim i As Integer
3:    On Error GoTo Err
    
5:    strScript = g_objFileAccess.ListFiles(G_APPPATH & "\Scripts\*.*")
 
7:    For i = 0 To UBound(strScript)
           Select Case LCase(g_objFileAccess.GetFileExt(strScript(i)))
                Case "vbs", "script", "js"
8:                    FoundScripts = True
9:                    Exit Function
            #If LUA Then
                Case "lua"
11:                    FoundScripts = True
12:                    Exit Function
            #End If
14:        End Select
15:    Next
    
17:    Exit Function
Err:
End Function

Private Sub LvwAddItem(ByVal intIndex As Integer, ByVal strName As String, ByVal strLanguage As String)
1:    On Error GoTo Err
2:    Dim lvwItem As Variant

      'NOTE: in Item.Tag and lvwItem.Key fasten the array index regarding the object Script Control
      'It will be used for Up / Down, to set script priority..
6:    Set lvwItem = frmHub.lvwScripts.ListItems.Add(intIndex, intIndex & "s", strName)

8:    lvwItem.SubItems(1) = "Inactive"
9:    lvwItem.SubItems(2) = strLanguage
10:    lvwItem.SubItems(3) = Now
11:    lvwItem.Tag = intIndex
12:    lvwItem.Key = (intIndex & "s")

14:   Set lvwItem = Nothing
    
16:   Exit Sub
17:
Err:
18:   HandleError Err.Number, Err.Description, Erl & "|" & "frmScript.LvwAddItem(" & intIndex & ", " & strName & ", " & strLanguage & ")"
End Sub

Private Sub Form_Unload(Cancel As Integer)
1:    Set frmScript = Nothing
End Sub

